home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / a_utils / perl / msds-prl / prl386l1.zoo / perl.c < prev    next >
C/C++ Source or Header  |  1992-07-29  |  40KB  |  1,477 lines
  1. static char rcsid2 = "$Id: PERL.C 1.1 92/07/19 14:25:51 doi Exp $";
  2. char rcsid[] = "RCSfile: perl.c,v Revision: 4.0.1.7 Date: 92/06/08 14:50:39 \nPatch level: ###\n";
  3. /*
  4.  *    Copyright (c) 1991, Larry Wall
  5.  *
  6.  *    You may distribute under the terms of either the GNU General Public
  7.  *    License or the Artistic License, as specified in the README file.
  8.  *
  9.  * Log:    perl.c,v 
  10.  * Revision 4.0.1.7  92/06/08  14:50:39  lwall
  11.  * patch20: PERLLIB now supports multiple directories
  12.  * patch20: running taintperl explicitly now does checks even if $< == $>
  13.  * patch20: -e 'cmd' no longer fails silently if /tmp runs out of space
  14.  * patch20: perl -P now uses location of sed determined by Configure
  15.  * patch20: form feed for formats is now specifiable via $^L
  16.  * patch20: paragraph mode now skips extra newlines automatically
  17.  * patch20: eval "1 #comment" didn't work
  18.  * patch20: couldn't require . files
  19.  * patch20: semantic compilation errors didn't abort execution
  20.  * 
  21.  * Revision 4.0.1.6  91/11/11  16:38:45  lwall
  22.  * patch19: default arg for shift was wrong after first subroutine definition
  23.  * patch19: op/regexp.t failed from missing arg to bcmp()
  24.  * 
  25.  * Revision 4.0.1.5  91/11/05  18:03:32  lwall
  26.  * patch11: random cleanup
  27.  * patch11: $0 was being truncated at times
  28.  * patch11: cppstdin now installed outside of source directory
  29.  * patch11: -P didn't allow use of #elif or #undef
  30.  * patch11: prepared for ctype implementations that don't define isascii()
  31.  * patch11: added eval {}
  32.  * patch11: eval confused by string containing null
  33.  * 
  34.  * Revision 4.0.1.4  91/06/10  01:23:07  lwall
  35.  * patch10: perl -v printed incorrect copyright notice
  36.  * 
  37.  * Revision 4.0.1.3  91/06/07  11:40:18  lwall
  38.  * patch4: changed old $^P to $^X
  39.  * 
  40.  * Revision 4.0.1.2  91/06/07  11:26:16  lwall
  41.  * patch4: new copyright notice
  42.  * patch4: added $^P variable to control calling of perldb routines
  43.  * patch4: added $^F variable to specify maximum system fd, default 2
  44.  * patch4: debugger lost track of lines in eval
  45.  * 
  46.  * Revision 4.0.1.1  91/04/11  17:49:05  lwall
  47.  * patch1: fixed undefined environ problem
  48.  * 
  49.  * Revision 4.0  91/03/20  01:37:44  lwall
  50.  * 4.0 baseline.
  51.  * 
  52.  */
  53.  
  54. /*SUPPRESS 560*/
  55.  
  56. #include "EXTERN.h"
  57. #include "perl.h"
  58. #include "perly.h"
  59. #include "patchlevel.h"
  60.  
  61. char *getenv();
  62.  
  63. #ifdef IAMSUID
  64. #ifndef DOSUID
  65. #define DOSUID
  66. #endif
  67. #endif
  68.  
  69. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  70. #ifdef DOSUID
  71. #undef DOSUID
  72. #endif
  73. #endif
  74.  
  75. static char* moreswitches();
  76. static void incpush();
  77. static char* cddir;
  78. static bool minus_c;
  79. static char patchlevel[6];
  80. static char *nrs = "\n";
  81. static int nrschar = '\n';      /* final char of rs, or 0777 if none */
  82. static int nrslen = 1;
  83.  
  84. main(argc,argv,env)
  85. #ifdef DJGPP
  86. int argc;
  87. char **argv;
  88. #else
  89. register int argc;
  90. register char **argv;
  91. #endif /* DJGPP */
  92. register char **env;
  93. {
  94.     register STR *str;
  95.     register char *s;
  96.     char *scriptname;
  97.     char *getenv();
  98.     bool dosearch = FALSE;
  99. #ifdef DOSUID
  100.     char *validarg = "";
  101. #endif
  102.  
  103. #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
  104. #ifdef IAMSUID
  105. #undef IAMSUID
  106.     fatal("suidperl is no longer needed since the kernel can now execute\n\
  107. setuid perl scripts securely.\n");
  108. #endif
  109. #endif
  110.  
  111. /*
  112.  * this is the args globbing in libglob.a - H.Doi
  113.  */
  114. #ifdef MSDOS
  115.   {
  116.     char **glob_filename();
  117.     int globargv();
  118.  
  119.     if (globargv(&argc, &argv, glob_filename)) {
  120.       fprintf(stderr, "globargv failed!\n");
  121.     }
  122.   }
  123. #endif /* MSDOS */
  124.  
  125.     origargv = argv;
  126.     origargc = argc;
  127.     origenviron = environ;
  128.     uid = (int)getuid();
  129.     euid = (int)geteuid();
  130.     gid = (int)getgid();
  131.     egid = (int)getegid();
  132.     sprintf(patchlevel,"%3.3s%2.2d", index(rcsid,'4'), PATCHLEVEL);
  133. #ifdef MSDOS
  134.     /*
  135.      * There is no way we can refer to them from Perl so close them to save
  136.      * space.  The other alternative would be to provide STDAUX and STDPRN
  137.      * filehandles.
  138.      */
  139. #ifndef DJGPP
  140.     (void)fclose(stdaux);
  141.     (void)fclose(stdprn);
  142. #endif /* !DJGPP */
  143. #endif
  144.     if (do_undump) {
  145.     origfilename = savestr(argv[0]);
  146.     do_undump = 0;
  147.     loop_ptr = -1;        /* start label stack again */
  148.     goto just_doit;
  149.     }
  150. #ifdef TAINT
  151. #ifndef DOSUID
  152.     if (uid == euid && gid == egid)
  153.     taintanyway == TRUE;        /* running taintperl explicitly */
  154. #endif
  155. #endif
  156.     (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
  157.     linestr = Str_new(65,80);
  158.     str_nset(linestr,"",0);
  159.     str = str_make("",0);        /* first used for -I flags */
  160.     curstash = defstash = hnew(0);
  161.     curstname = str_make("main",4);
  162.     stab_xhash(stabent("_main",TRUE)) = defstash;
  163.     defstash->tbl_name = "main";
  164.     incstab = hadd(aadd(stabent("INC",TRUE)));
  165.     incstab->str_pok |= SP_MULTI;
  166.     for (argc--,argv++; argc > 0; argc--,argv++) {
  167.     if (argv[0][0] != '-' || !argv[0][1])
  168.         break;
  169. #ifdef DOSUID
  170.     if (*validarg)
  171.     validarg = " PHOOEY ";
  172.     else
  173.     validarg = argv[0];
  174. #endif
  175.     s = argv[0]+1;
  176.       reswitch:
  177.     switch (*s) {
  178.     case '0':
  179.     case 'a':
  180.     case 'c':
  181.     case 'd':
  182.     case 'D':
  183.     case 'i':
  184.     case 'l':
  185.     case 'n':
  186.     case 'p':
  187.     case 'u':
  188.     case 'U':
  189.     case 'v':
  190.     case 'w':
  191.         if (s = moreswitches(s))
  192.         goto reswitch;
  193.         break;
  194.  
  195.     case 'e':
  196. #ifdef TAINT
  197.         if (euid != uid || egid != gid)
  198.         fatal("No -e allowed in setuid scripts");
  199. #endif
  200.         if (!e_fp) {
  201.             e_tmpname = savestr(TMPPATH);
  202.         (void)mktemp(e_tmpname);
  203.         if (!*e_tmpname)
  204.             fatal("Can't mktemp()");
  205.         e_fp = fopen(e_tmpname,"w");
  206.         if (!e_fp)
  207.             fatal("Cannot open temporary file");
  208.         }
  209.         if (argv[1]) {
  210.         fputs(argv[1],e_fp);
  211.         argc--,argv++;
  212.         }
  213.         (void)putc('\n', e_fp);
  214.         break;
  215.     case 'I':
  216. #ifdef TAINT
  217.         if (euid != uid || egid != gid)
  218.         fatal("No -I allowed in setuid scripts");
  219. #endif
  220.         str_cat(str,"-");
  221.         str_cat(str,s);
  222.         str_cat(str," ");
  223.         if (*++s) {
  224.         (void)apush(stab_array(incstab),str_make(s,0));
  225.         }
  226.         else if (argv[1]) {
  227.         (void)apush(stab_array(incstab),str_make(argv[1],0));
  228.         str_cat(str,argv[1]);
  229.         argc--,argv++;
  230.         str_cat(str," ");
  231.         }
  232.         break;
  233.     case 'P':
  234. #ifdef TAINT
  235.         if (euid != uid || egid != gid)
  236.         fatal("No -P allowed in setuid scripts");
  237. #endif
  238.         preprocess = TRUE;
  239.         s++;
  240.         goto reswitch;
  241.     case 's':
  242. #ifdef TAINT
  243.         if (euid != uid || egid != gid)
  244.         fatal("No -s allowed in setuid scripts");
  245. #endif
  246.         doswitches = TRUE;
  247.         s++;
  248.         goto reswitch;
  249.     case 'S':
  250. #ifdef TAINT
  251.         if (euid != uid || egid != gid)
  252.         fatal("No -S allowed in setuid scripts");
  253. #endif
  254.         dosearch = TRUE;
  255.         s++;
  256.         goto reswitch;
  257.     case 'x':
  258.         doextract = TRUE;
  259.         s++;
  260.         if (*s)
  261.         cddir = savestr(s);
  262.         break;
  263.     case '-':
  264.         argc--,argv++;
  265.         goto switch_end;
  266.     case 0:
  267.         break;
  268.     default:
  269.         fatal("Unrecognized switch: -%s",s);
  270.     }
  271.     }
  272.   switch_end:
  273.     scriptname = argv[0];
  274.     if (e_fp) {
  275.     if (fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
  276.         fatal("Can't write to temp file for -e: %s", strerror(errno));
  277.     argc++,argv--;
  278.     scriptname = e_tmpname;
  279.     }
  280.  
  281. #ifdef DOSISH
  282. #define PERLLIB_SEP ';'
  283. #else
  284. #define PERLLIB_SEP ':'
  285. #endif
  286. #ifndef TAINT        /* Can't allow arbitrary PERLLIB in setuid script */
  287.     incpush(getenv("PERLLIB"));
  288. #endif /* TAINT */
  289.  
  290. #ifndef PRIVLIB
  291. #define PRIVLIB "/usr/local/lib/perl"
  292. #endif
  293.     incpush(PRIVLIB);
  294.     (void)apush(stab_array(incstab),str_make(".",1));
  295.  
  296.     str_set(&str_no,No);
  297.     str_set(&str_yes,Yes);
  298.  
  299.     /* open script */
  300.  
  301.     if (scriptname == Nullch)
  302. #ifdef MSDOS
  303.     {
  304.     if ( isatty(fileno(stdin)) )
  305.       moreswitches("v");
  306.     scriptname = "-";
  307.     }
  308. #else
  309.     scriptname = "-";
  310. #endif
  311.     if (dosearch && !index(scriptname, '/') && (s = getenv("PATH"))) {
  312.     char *xfound = Nullch, *xfailed = Nullch;
  313.     int len;
  314.  
  315.     bufend = s + strlen(s);
  316.     while (*s) {
  317. #ifndef DOSISH
  318.         s = cpytill(tokenbuf,s,bufend,':',&len);
  319. #else
  320. #ifdef atarist
  321.         for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
  322.         tokenbuf[len] = '\0';
  323. #else
  324.         for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
  325.         tokenbuf[len] = '\0';
  326. #endif
  327. #endif
  328.         if (*s)
  329.         s++;
  330. #ifndef DOSISH
  331.         if (len && tokenbuf[len-1] != '/')
  332. #else
  333. #ifdef atarist
  334.         if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
  335. #else
  336.         if (len && tokenbuf[len-1] != '\\')
  337. #endif
  338. #endif
  339.         (void)strcat(tokenbuf+len,"/");
  340.         (void)strcat(tokenbuf+len,scriptname);
  341. #ifdef DEBUGGING
  342.         if (debug & 1)
  343.         fprintf(stderr,"Looking for %s\n",tokenbuf);
  344. #endif
  345.         if (stat(tokenbuf,&statbuf) < 0)        /* not there? */
  346.         continue;
  347.         if (S_ISREG(statbuf.st_mode)
  348.          && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
  349.         xfound = tokenbuf;              /* bingo! */
  350.         break;
  351.         }
  352.         if (!xfailed)
  353.         xfailed = savestr(tokenbuf);
  354.     }
  355.     if (!xfound)
  356.         fatal("Can't execute %s", xfailed ? xfailed : scriptname );
  357.     if (xfailed)
  358.         Safefree(xfailed);
  359.     scriptname = savestr(xfound);
  360.     }
  361.  
  362.     fdpid = anew(Nullstab);    /* for remembering popen pids by fd */
  363.     pidstatus = hnew(COEFFSIZE);/* for remembering status of dead pids */
  364.  
  365.     origfilename = savestr(scriptname);
  366.     curcmd->c_filestab = fstab(origfilename);
  367.     if (strEQ(origfilename,"-"))
  368.     scriptname = "";
  369.     if (preprocess) {
  370.     char *cpp = CPPSTDIN;
  371.  
  372.     if (strEQ(cpp,"cppstdin"))
  373.         sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
  374.     else
  375.         sprintf(tokenbuf, "%s", cpp);
  376.     str_cat(str,"-I");
  377.     str_cat(str,PRIVLIB);
  378. #ifdef MSDOS
  379.     (void)sprintf(buf, "\
  380. sed %s -e \"/^[^#]/b\" \
  381.  -e \"/^#[     ]*include[     ]/b\" \
  382.  -e \"/^#[     ]*define[     ]/b\" \
  383.  -e \"/^#[     ]*if[     ]/b\" \
  384.  -e \"/^#[     ]*ifdef[     ]/b\" \
  385.  -e \"/^#[     ]*ifndef[     ]/b\" \
  386.  -e \"/^#[     ]*else/b\" \
  387.  -e \"/^#[     ]*elif[     ]/b\" \
  388.  -e \"/^#[     ]*undef[     ]/b\" \
  389.  -e \"/^#[     ]*endif/b\" \
  390.  -e \"s/^#.*//\" \
  391.  %s | %s -C %s %s",
  392.       (doextract ? "-e \"1,/^#/d\n\"" : ""),
  393. #else
  394.     (void)sprintf(buf, "\
  395. %s %s -e '/^[^#]/b' \
  396.  -e '/^#[     ]*include[     ]/b' \
  397.  -e '/^#[     ]*define[     ]/b' \
  398.  -e '/^#[     ]*if[     ]/b' \
  399.  -e '/^#[     ]*ifdef[     ]/b' \
  400.  -e '/^#[     ]*ifndef[     ]/b' \
  401.  -e '/^#[     ]*else/b' \
  402.  -e '/^#[     ]*elif[     ]/b' \
  403.  -e '/^#[     ]*undef[     ]/b' \
  404.  -e '/^#[     ]*endif/b' \
  405.  -e 's/^[     ]*#.*//' \
  406.  %s | %s -C %s %s",
  407. #ifdef LOC_SED
  408.       LOC_SED,
  409. #else
  410.       "sed",
  411. #endif
  412.       (doextract ? "-e '1,/^#/d\n'" : ""),
  413. #endif
  414.       scriptname, tokenbuf, str_get(str), CPPMINUS);
  415. #ifdef DEBUGGING
  416.     if (debug & 64) {
  417.         fputs(buf,stderr);
  418.         fputs("\n",stderr);
  419.     }
  420. #endif
  421.     doextract = FALSE;
  422. #ifdef IAMSUID                /* actually, this is caught earlier */
  423.     if (euid != uid && !euid) {    /* if running suidperl */
  424. #ifdef HAS_SETEUID
  425.         (void)seteuid(uid);        /* musn't stay setuid root */
  426. #else
  427. #ifdef HAS_SETREUID
  428.         (void)setreuid(-1, uid);
  429. #else
  430.         setuid(uid);
  431. #endif
  432. #endif
  433.         if (geteuid() != uid)
  434.         fatal("Can't do seteuid!\n");
  435.     }
  436. #endif /* IAMSUID */
  437.     rsfp = mypopen(buf,"r");
  438.     }
  439.     else if (!*scriptname) {
  440. #ifdef TAINT
  441.     if (euid != uid || egid != gid)
  442.         fatal("Can't take set-id script from stdin");
  443. #endif
  444.     rsfp = stdin;
  445.     }
  446.     else
  447.     rsfp = fopen(scriptname,"r");
  448.     if ((FILE*)rsfp == Nullfp) {
  449. #ifdef DOSUID
  450. #ifndef IAMSUID        /* in case script is not readable before setuid */
  451.     if (euid && stat(stab_val(curcmd->c_filestab)->str_ptr,&statbuf) >= 0 &&
  452.       statbuf.st_mode & (S_ISUID|S_ISGID)) {
  453.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  454. #ifndef DJGPP
  455.         execv(buf, origargv);    /* try again */
  456. #endif /* !DJGPP */
  457.         fatal("Can't do setuid\n");
  458.     }
  459. #endif
  460. #endif
  461.     fatal("Can't open perl script \"%s\": %s\n",
  462.       stab_val(curcmd->c_filestab)->str_ptr, strerror(errno));
  463.     }
  464.     str_free(str);        /* free -I directories */
  465.     str = Nullstr;
  466.  
  467.     /* do we need to emulate setuid on scripts? */
  468.  
  469.     /* This code is for those BSD systems that have setuid #! scripts disabled
  470.      * in the kernel because of a security problem.  Merely defining DOSUID
  471.      * in perl will not fix that problem, but if you have disabled setuid
  472.      * scripts in the kernel, this will attempt to emulate setuid and setgid
  473.      * on scripts that have those now-otherwise-useless bits set.  The setuid
  474.      * root version must be called suidperl or sperlN.NNN.  If regular perl
  475.      * discovers that it has opened a setuid script, it calls suidperl with
  476.      * the same argv that it had.  If suidperl finds that the script it has
  477.      * just opened is NOT setuid root, it sets the effective uid back to the
  478.      * uid.  We don't just make perl setuid root because that loses the
  479.      * effective uid we had before invoking perl, if it was different from the
  480.      * uid.
  481.      *
  482.      * DOSUID must be defined in both perl and suidperl, and IAMSUID must
  483.      * be defined in suidperl only.  suidperl must be setuid root.  The
  484.      * Configure script will set this up for you if you want it.
  485.      *
  486.      * There is also the possibility of have a script which is running
  487.      * set-id due to a C wrapper.  We want to do the TAINT checks
  488.      * on these set-id scripts, but don't want to have the overhead of
  489.      * them in normal perl, and can't use suidperl because it will lose
  490.      * the effective uid info, so we have an additional non-setuid root
  491.      * version called taintperl or tperlN.NNN that just does the TAINT checks.
  492.      */
  493.  
  494. #ifdef DOSUID
  495.     if (fstat(fileno(rsfp),&statbuf) < 0)    /* normal stat is insecure */
  496.     fatal("Can't stat script \"%s\"",origfilename);
  497.     if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
  498.     int len;
  499.  
  500. #ifdef IAMSUID
  501. #ifndef HAS_SETREUID
  502.     /* On this access check to make sure the directories are readable,
  503.      * there is actually a small window that the user could use to make
  504.      * filename point to an accessible directory.  So there is a faint
  505.      * chance that someone could execute a setuid script down in a
  506.      * non-accessible directory.  I don't know what to do about that.
  507.      * But I don't think it's too important.  The manual lies when
  508.      * it says access() is useful in setuid programs.
  509.      */
  510.     if (access(stab_val(curcmd->c_filestab)->str_ptr,1))    /*double check*/
  511.         fatal("Permission denied");
  512. #else
  513.     /* If we can swap euid and uid, then we can determine access rights
  514.      * with a simple stat of the file, and then compare device and
  515.      * inode to make sure we did stat() on the same file we opened.
  516.      * Then we just have to make sure he or she can execute it.
  517.      */
  518.     {
  519.         struct stat tmpstatbuf;
  520.  
  521.         if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
  522.         fatal("Can't swap uid and euid");    /* really paranoid */
  523.         if (stat(stab_val(curcmd->c_filestab)->str_ptr,&tmpstatbuf) < 0)
  524.         fatal("Permission denied");    /* testing full pathname here */
  525.         if (tmpstatbuf.st_dev != statbuf.st_dev ||
  526.         tmpstatbuf.st_ino != statbuf.st_ino) {
  527.         (void)fclose(rsfp);
  528.         if (rsfp = mypopen("/bin/mail root","w")) {    /* heh, heh */
  529.             fprintf(rsfp,
  530. "User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
  531. (Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
  532.             uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
  533.             statbuf.st_dev, statbuf.st_ino,
  534.             stab_val(curcmd->c_filestab)->str_ptr,
  535.             statbuf.st_uid, statbuf.st_gid);
  536.             (void)mypclose(rsfp);
  537.         }
  538.         fatal("Permission denied\n");
  539.         }
  540.         if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
  541.         fatal("Can't reswap uid and euid");
  542.         if (!cando(S_IXUSR,FALSE,&statbuf))        /* can real uid exec? */
  543.         fatal("Permission denied\n");
  544.     }
  545. #endif /* HAS_SETREUID */
  546. #endif /* IAMSUID */
  547.  
  548.     if (!S_ISREG(statbuf.st_mode))
  549.         fatal("Permission denied");
  550.     if (statbuf.st_mode & S_IWOTH)
  551.         fatal("Setuid/gid script is writable by world");
  552.     doswitches = FALSE;        /* -s is insecure in suid */
  553.     curcmd->c_line++;
  554.     if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
  555.       strnNE(tokenbuf,"#!",2) )    /* required even on Sys V */
  556.         fatal("No #! line");
  557.     s = tokenbuf+2;
  558.     if (*s == ' ') s++;
  559.     while (!isSPACE(*s)) s++;
  560.     if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4))  /* sanity check */
  561.         fatal("Not a perl script");
  562.     while (*s == ' ' || *s == '\t') s++;
  563.     /*
  564.      * #! arg must be what we saw above.  They can invoke it by
  565.      * mentioning suidperl explicitly, but they may not add any strange
  566.      * arguments beyond what #! says if they do invoke suidperl that way.
  567.      */
  568.     len = strlen(validarg);
  569.     if (strEQ(validarg," PHOOEY ") ||
  570.         strnNE(s,validarg,len) || !isSPACE(s[len]))
  571.         fatal("Args must match #! line");
  572.  
  573. #ifndef IAMSUID
  574.     if (euid != uid && (statbuf.st_mode & S_ISUID) &&
  575.         euid == statbuf.st_uid)
  576.         if (!do_undump)
  577.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  578. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  579. #endif /* IAMSUID */
  580.  
  581.     if (euid) {    /* oops, we're not the setuid root perl */
  582.         (void)fclose(rsfp);
  583. #ifndef IAMSUID
  584.         (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
  585. #ifndef DJGPP
  586.         execv(buf, origargv);    /* try again */
  587. #endif /* !DJGPP */
  588. #endif
  589.         fatal("Can't do setuid\n");
  590.     }
  591.  
  592.     if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
  593. #ifdef HAS_SETEGID
  594.         (void)setegid(statbuf.st_gid);
  595. #else
  596. #ifdef HAS_SETREGID
  597.         (void)setregid((GIDTYPE)-1,statbuf.st_gid);
  598. #else
  599.         setgid(statbuf.st_gid);
  600. #endif
  601. #endif
  602.         if (getegid() != statbuf.st_gid)
  603.         fatal("Can't do setegid!\n");
  604.     }
  605.     if (statbuf.st_mode & S_ISUID) {
  606.         if (statbuf.st_uid != euid)
  607. #ifdef HAS_SETEUID
  608.         (void)seteuid(statbuf.st_uid);    /* all that for this */
  609. #else
  610. #ifdef HAS_SETREUID
  611.         (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
  612. #else
  613.         setuid(statbuf.st_uid);
  614. #endif
  615. #endif
  616.         if (geteuid() != statbuf.st_uid)
  617.         fatal("Can't do seteuid!\n");
  618.     }
  619.     else if (uid) {            /* oops, mustn't run as root */
  620. #ifdef HAS_SETEUID
  621.         (void)seteuid((UIDTYPE)uid);
  622. #else
  623. #ifdef HAS_SETREUID
  624.         (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
  625. #else
  626.         setuid((UIDTYPE)uid);
  627. #endif
  628. #endif
  629.         if (geteuid() != uid)
  630.         fatal("Can't do seteuid!\n");
  631.     }
  632.     uid = (int)getuid();
  633.     euid = (int)geteuid();
  634.     gid = (int)getgid();
  635.     egid = (int)getegid();
  636.     if (!cando(S_IXUSR,TRUE,&statbuf))
  637.         fatal("Permission denied\n");    /* they can't do this */
  638.     }
  639. #ifdef IAMSUID
  640.     else if (preprocess)
  641.     fatal("-P not allowed for setuid/setgid script\n");
  642.     else
  643.     fatal("Script is not setuid/setgid in suidperl\n");
  644. #else
  645. #ifndef TAINT        /* we aren't taintperl or suidperl */
  646.     /* script has a wrapper--can't run suidperl or we lose euid */
  647.     else if (euid != uid || egid != gid) {
  648.     (void)fclose(rsfp);
  649.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  650. #ifndef DJGPP
  651.     execv(buf, origargv);    /* try again */
  652. #endif /* !DJGPP */
  653.     fatal("Can't run setuid script with taint checks");
  654.     }
  655. #endif /* TAINT */
  656. #endif /* IAMSUID */
  657. #else /* !DOSUID */
  658. #ifndef TAINT        /* we aren't taintperl or suidperl */
  659.     if (euid != uid || egid != gid) {    /* (suidperl doesn't exist, in fact) */
  660. #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
  661.     fstat(fileno(rsfp),&statbuf);    /* may be either wrapped or real suid */
  662.     if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
  663.         ||
  664.         (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
  665.        )
  666.         if (!do_undump)
  667.         fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
  668. FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
  669. #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
  670.     /* not set-id, must be wrapped */
  671.     (void)fclose(rsfp);
  672.     (void)sprintf(buf, "%s/tperl%s", BIN, patchlevel);
  673. #ifndef DJGPP
  674.     execv(buf, origargv);    /* try again */
  675. #endif /* !DJGPP */
  676.     fatal("Can't run setuid script with taint checks");
  677.     }
  678. #endif /* TAINT */
  679. #endif /* DOSUID */
  680.  
  681. #if !defined(IAMSUID) && !defined(TAINT)
  682.  
  683.     /* skip forward in input to the real script? */
  684.  
  685.     while (doextract) {
  686.     if ((s = str_gets(linestr, rsfp, 0)) == Nullch)
  687.         fatal("No Perl script found in input\n");
  688.     if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
  689.         ungetc('\n',rsfp);        /* to keep line count right */
  690.         doextract = FALSE;
  691.         if (s = instr(s,"perl -")) {
  692.         s += 6;
  693.         /*SUPPRESS 530*/
  694.         while (s = moreswitches(s)) ;
  695.         }
  696.         if (cddir && chdir(cddir) < 0)
  697.         fatal("Can't chdir to %s",cddir);
  698.     }
  699.     }
  700. #endif /* !defined(IAMSUID) && !defined(TAINT) */
  701.  
  702.     defstab = stabent("_",TRUE);
  703.  
  704.     subname = str_make("main",4);
  705.     if (perldb) {
  706.     debstash = hnew(0);
  707.     stab_xhash(stabent("_DB",TRUE)) = debstash;
  708.     curstash = debstash;
  709.     dbargs = stab_xarray(aadd((tmpstab = stabent("args",TRUE))));
  710.     tmpstab->str_pok |= SP_MULTI;
  711.     dbargs->ary_flags = 0;
  712.     DBstab = stabent("DB",TRUE);
  713.     DBstab->str_pok |= SP_MULTI;
  714.     DBline = stabent("dbline",TRUE);
  715.     DBline->str_pok |= SP_MULTI;
  716.     DBsub = hadd(tmpstab = stabent("sub",TRUE));
  717.     tmpstab->str_pok |= SP_MULTI;
  718.     DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
  719.     tmpstab->str_pok |= SP_MULTI;
  720.     DBtrace = stab_val((tmpstab = stabent("trace",TRUE)));
  721.     tmpstab->str_pok |= SP_MULTI;
  722.     DBsignal = stab_val((tmpstab = stabent("signal",TRUE)));
  723.     tmpstab->str_pok |= SP_MULTI;
  724.     curstash = defstash;
  725.     }
  726.  
  727.     /* init tokener */
  728.  
  729.     bufend = bufptr = str_get(linestr);
  730.  
  731.     savestack = anew(Nullstab);        /* for saving non-local values */
  732.     stack = anew(Nullstab);        /* for saving non-local values */
  733.     stack->ary_flags = 0;        /* not a real array */
  734.     afill(stack,63); afill(stack,-1);    /* preextend stack */
  735.     afill(savestack,63); afill(savestack,-1);
  736.  
  737.     /* now parse the script */
  738.  
  739.     error_count = 0;
  740.     if (yyparse() || error_count) {
  741.     if (minus_c)
  742.         fatal("%s had compilation errors.\n", origfilename);
  743.     else {
  744.         fatal("Execution of %s aborted due to compilation errors.\n",
  745.         origfilename);
  746.     }
  747.     }
  748.  
  749.     New(50,loop_stack,128,struct loop);
  750. #ifdef DEBUGGING
  751.     if (debug) {
  752.     New(51,debname,128,char);
  753.     New(52,debdelim,128,char);
  754.     }
  755. #endif
  756.     curstash = defstash;
  757.  
  758.     preprocess = FALSE;
  759.     if (e_fp) {
  760.     e_fp = Nullfp;
  761.     (void)UNLINK(e_tmpname);
  762.     }
  763.  
  764.     /* initialize everything that won't change if we undump */
  765.  
  766.     if (sigstab = stabent("SIG",allstabs)) {
  767.     sigstab->str_pok |= SP_MULTI;
  768.     (void)hadd(sigstab);
  769.     }
  770.  
  771.     magicalize("!#?^~=-%.+&*()<>,\\/[|`':\004\t\020\024\027\006");
  772.     userinit();        /* in case linked C routines want magical variables */
  773.  
  774.     amperstab = stabent("&",allstabs);
  775.     leftstab = stabent("`",allstabs);
  776.     rightstab = stabent("'",allstabs);
  777.     sawampersand = (amperstab || leftstab || rightstab);
  778.     if (tmpstab = stabent(":",allstabs))
  779.     str_set(stab_val(tmpstab),chopset);
  780.     if (tmpstab = stabent("\024",allstabs))
  781.     time(&basetime);
  782.  
  783.     /* these aren't necessarily magical */
  784.     if (tmpstab = stabent("\014",allstabs)) {
  785.     str_set(stab_val(tmpstab),"\f");
  786.     formfeed = stab_val(tmpstab);
  787.     }
  788.     if (tmpstab = stabent(";",allstabs))
  789.     str_set(STAB_STR(tmpstab),"\034");
  790.     if (tmpstab = stabent("]",allstabs)) {
  791.     str = STAB_STR(tmpstab);
  792.     str_set(str,rcsid);
  793.     str->str_u.str_nval = atof(patchlevel);
  794.     str->str_nok = 1;
  795.     }
  796.     str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
  797.  
  798.     stdinstab = stabent("STDIN",TRUE);
  799.     stdinstab->str_pok |= SP_MULTI;
  800.     if (!stab_io(stdinstab))
  801.     stab_io(stdinstab) = stio_new();
  802.     stab_io(stdinstab)->ifp = stdin;
  803.     tmpstab = stabent("stdin",TRUE);
  804.     stab_io(tmpstab) = stab_io(stdinstab);
  805.     tmpstab->str_pok |= SP_MULTI;
  806.  
  807.     tmpstab = stabent("STDOUT",TRUE);
  808.     tmpstab->str_pok |= SP_MULTI;
  809.     if (!stab_io(tmpstab))
  810.     stab_io(tmpstab) = stio_new();
  811.     stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
  812.     defoutstab = tmpstab;
  813.     tmpstab = stabent("stdout",TRUE);
  814.     stab_io(tmpstab) = stab_io(defoutstab);
  815.     tmpstab->str_pok |= SP_MULTI;
  816.  
  817.     curoutstab = stabent("STDERR",TRUE);
  818.     curoutstab->str_pok |= SP_MULTI;
  819.     if (!stab_io(curoutstab))
  820.     stab_io(curoutstab) = stio_new();
  821.     stab_io(curoutstab)->ofp = stab_io(curoutstab)->ifp = stderr;
  822.     tmpstab = stabent("stderr",TRUE);
  823.     stab_io(tmpstab) = stab_io(curoutstab);
  824.     tmpstab->str_pok |= SP_MULTI;
  825.     curoutstab = defoutstab;        /* switch back to STDOUT */
  826.  
  827.     statname = Str_new(66,0);        /* last filename we did stat on */
  828.  
  829.     /* now that script is parsed, we can modify record separator */
  830.  
  831.     rs = nrs;
  832.     rslen = nrslen;
  833.     rschar = nrschar;
  834.     rspara = (nrslen == 2);
  835.     str_nset(stab_val(stabent("/", TRUE)), rs, rslen);
  836.  
  837.     if (do_undump)
  838.     my_unexec();
  839.  
  840.   just_doit:        /* come here if running an undumped a.out */
  841.     argc--,argv++;    /* skip name of script */
  842.     if (doswitches) {
  843.     for (; argc > 0 && **argv == '-'; argc--,argv++) {
  844.         if (argv[0][1] == '-') {
  845.         argc--,argv++;
  846.         break;
  847.         }
  848.         if (s = index(argv[0], '=')) {
  849.         *s++ = '\0';
  850.         str_set(stab_val(stabent(argv[0]+1,TRUE)),s);
  851.         }
  852.         else
  853.         str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
  854.     }
  855.     }
  856. #ifdef TAINT
  857.     tainted = 1;
  858. #endif
  859.     if (tmpstab = stabent("0",allstabs)) {
  860.     str_set(stab_val(tmpstab),origfilename);
  861.     magicname("0", Nullch, 0);
  862.     }
  863.     if (tmpstab = stabent("\030",allstabs))
  864.     str_set(stab_val(tmpstab),origargv[0]);
  865.     if (argvstab = stabent("ARGV",allstabs)) {
  866.     argvstab->str_pok |= SP_MULTI;
  867.     (void)aadd(argvstab);
  868.     aclear(stab_array(argvstab));
  869.     for (; argc > 0; argc--,argv++) {
  870.         (void)apush(stab_array(argvstab),str_make(argv[0],0));
  871.     }
  872.     }
  873. #ifdef TAINT
  874.     (void) stabent("ENV",TRUE);        /* must test PATH and IFS */
  875. #endif
  876.     if (envstab = stabent("ENV",allstabs)) {
  877.     envstab->str_pok |= SP_MULTI;
  878.     (void)hadd(envstab);
  879.     hclear(stab_hash(envstab), FALSE);
  880.     if (env != environ)
  881.         environ[0] = Nullch;
  882.     for (; *env; env++) {
  883.         if (!(s = index(*env,'=')))
  884.         continue;
  885.         *s++ = '\0';
  886.         str = str_make(s--,0);
  887.         str_magic(str, envstab, 'E', *env, s - *env);
  888.         (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
  889.         *s = '=';
  890.     }
  891.     }
  892. #ifdef TAINT
  893.     tainted = 0;
  894. #endif
  895.     if (tmpstab = stabent("$",allstabs))
  896.     str_numset(STAB_STR(tmpstab),(double)getpid());
  897.  
  898.     if (dowarn) {
  899.     stab_check('A','Z');
  900.     stab_check('a','z');
  901.     }
  902.  
  903.     if (setjmp(top_env))    /* sets goto_targ on longjump */
  904.     loop_ptr = -1;        /* start label stack again */
  905.  
  906. #ifdef DEBUGGING
  907.     if (debug & 1024)
  908.     dump_all();
  909.     if (debug)
  910.     fprintf(stderr,"\nEXECUTING...\n\n");
  911. #endif
  912.  
  913.     if (minus_c) {
  914.     fprintf(stderr,"%s syntax OK\n", origfilename);
  915.     exit(0);
  916.     }
  917.  
  918.     /* do it */
  919.  
  920.     (void) cmd_exec(main_root,G_SCALAR,-1);
  921.  
  922.     if (goto_targ)
  923.     fatal("Can't find label \"%s\"--aborting",goto_targ);
  924.     exit(0);
  925.     /* NOTREACHED */
  926. }
  927.  
  928. void
  929. magicalize(list)
  930. register char *list;
  931. {
  932.     char sym[2];
  933.  
  934.     sym[1] = '\0';
  935.     while (*sym = *list++)
  936.     magicname(sym, Nullch, 0);
  937. }
  938.  
  939. void
  940. magicname(sym,name,namlen)
  941. char *sym;
  942. char *name;
  943. int namlen;
  944. {
  945.     register STAB *stab;
  946.  
  947.     if (stab = stabent(sym,allstabs)) {
  948.     stab_flags(stab) = SF_VMAGIC;
  949.     str_magic(stab_val(stab), stab, 0, name, namlen);
  950.     }
  951. }
  952.  
  953. static void
  954. incpush(p)
  955. char *p;
  956. {
  957.     char *s;
  958.  
  959.     if (!p)
  960.     return;
  961.  
  962.     /* Break at all separators */
  963.     while (*p) {
  964.     /* First, skip any consecutive separators */
  965.     while ( *p == PERLLIB_SEP ) {
  966.         /* Uncomment the next line for PATH semantics */
  967.         /* (void)apush(stab_array(incstab), str_make(".", 1)); */
  968.         p++;
  969.     }
  970.     if ( (s = index(p, PERLLIB_SEP)) != Nullch ) {
  971.         (void)apush(stab_array(incstab), str_make(p, (int)(s - p)));
  972.         p = s + 1;
  973.     } else {
  974.         (void)apush(stab_array(incstab), str_make(p, 0));
  975.         break;
  976.     }
  977.     }
  978. }
  979.  
  980. void
  981. savelines(array, str)
  982. ARRAY *array;
  983. STR *str;
  984. {
  985.     register char *s = str->str_ptr;
  986.     register char *send = str->str_ptr + str->str_cur;
  987.     register char *t;
  988.     register int line = 1;
  989.  
  990.     while (s && s < send) {
  991.     STR *tmpstr = Str_new(85,0);
  992.  
  993.     t = index(s, '\n');
  994.     if (t)
  995.         t++;
  996.     else
  997.         t = send;
  998.  
  999.     str_nset(tmpstr, s, t - s);
  1000.     astore(array, line++, tmpstr);
  1001.     s = t;
  1002.     }
  1003. }
  1004.  
  1005. /* this routine is in perl.c by virtue of being sort of an alternate main() */
  1006.  
  1007. int
  1008. do_eval(str,optype,stash,savecmd,gimme,arglast)
  1009. STR *str;
  1010. int optype;
  1011. HASH *stash;
  1012. int savecmd;
  1013. int gimme;
  1014. int *arglast;
  1015. {
  1016.     STR **st = stack->ary_array;
  1017.     int retval;
  1018.     CMD *myroot = Nullcmd;
  1019.     ARRAY *ar;
  1020.     int i;
  1021.     CMD * VOLATILE oldcurcmd = curcmd;
  1022.     VOLATILE int oldtmps_base = tmps_base;
  1023.     VOLATILE int oldsave = savestack->ary_fill;
  1024.     VOLATILE int oldperldb = perldb;
  1025.     SPAT * VOLATILE oldspat = curspat;
  1026.     SPAT * VOLATILE oldlspat = lastspat;
  1027.     static char *last_eval = Nullch;
  1028.     static long last_elen = 0;
  1029.     static CMD *last_root = Nullcmd;
  1030.     VOLATILE int sp = arglast[0];
  1031.     char *specfilename;
  1032.     char *tmpfilename;
  1033.     int parsing = 1;
  1034.  
  1035.     tmps_base = tmps_max;
  1036.     if (curstash != stash) {
  1037.     (void)savehptr(&curstash);
  1038.     curstash = stash;
  1039.     }
  1040.     str_set(stab_val(stabent("@",TRUE)),"");
  1041.     if (curcmd->c_line == 0)        /* don't debug debugger... */
  1042.     perldb = FALSE;
  1043.     curcmd = &compiling;
  1044.     if (optype == O_EVAL) {        /* normal eval */
  1045.     curcmd->c_filestab = fstab("(eval)");
  1046.     curcmd->c_line = 1;
  1047.     str_sset(linestr,str);
  1048.     str_cat(linestr,";\n;\n");    /* be kind to them */
  1049.     if (perldb)
  1050.         savelines(stab_xarray(curcmd->c_filestab), linestr);
  1051.     }
  1052.     else {
  1053.     if (last_root && !in_eval) {
  1054.         Safefree(last_eval);
  1055.         last_eval = Nullch;
  1056.         cmd_free(last_root);
  1057.         last_root = Nullcmd;
  1058.     }
  1059.     specfilename = str_get(str);
  1060.     str_set(linestr,"");
  1061.     if (optype == O_REQUIRE && &str_undef !=
  1062.       hfetch(stab_hash(incstab), specfilename, strlen(specfilename), 0)) {
  1063.         curcmd = oldcurcmd;
  1064.         tmps_base = oldtmps_base;
  1065.         st[++sp] = &str_yes;
  1066.         perldb = oldperldb;
  1067.         return sp;
  1068.     }
  1069.     tmpfilename = savestr(specfilename);
  1070.     if (*tmpfilename == '/' ||
  1071.         (*tmpfilename == '.' && 
  1072.         (tmpfilename[1] == '/' ||
  1073.          (tmpfilename[1] == '.' && tmpfilename[2] == '/'))))
  1074.     {
  1075.         rsfp = fopen(tmpfilename,"r");
  1076.     }
  1077.     else {
  1078.         ar = stab_array(incstab);
  1079.         for (i = 0; i <= ar->ary_fill; i++) {
  1080.         (void)sprintf(buf, "%s/%s",
  1081.           str_get(afetch(ar,i,TRUE)), specfilename);
  1082.         rsfp = fopen(buf,"r");
  1083.         if (rsfp) {
  1084.             char *s = buf;
  1085.  
  1086.             if (*s == '.' && s[1] == '/')
  1087.             s += 2;
  1088.             Safefree(tmpfilename);
  1089.             tmpfilename = savestr(s);
  1090.             break;
  1091.         }
  1092.         }
  1093.     }
  1094.     curcmd->c_filestab = fstab(tmpfilename);
  1095.     Safefree(tmpfilename);
  1096.     tmpfilename = Nullch;
  1097.     if (!rsfp) {
  1098.         curcmd = oldcurcmd;
  1099.         tmps_base = oldtmps_base;
  1100.         if (optype == O_REQUIRE) {
  1101.         sprintf(tokenbuf,"Can't locate %s in @INC", specfilename);
  1102.         if (instr(tokenbuf,".h "))
  1103.             strcat(tokenbuf," (change .h to .ph maybe?)");
  1104.         if (instr(tokenbuf,".ph "))
  1105.             strcat(tokenbuf," (did you run h2ph?)");
  1106.         fatal("%s",tokenbuf);
  1107.         }
  1108.         if (gimme != G_ARRAY)
  1109.         st[++sp] = &str_undef;
  1110.         perldb = oldperldb;
  1111.         return sp;
  1112.     }
  1113.     curcmd->c_line = 0;
  1114.     }
  1115.     in_eval++;
  1116.     oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
  1117.     bufend = bufptr + linestr->str_cur;
  1118.     if (++loop_ptr >= loop_max) {
  1119.     loop_max += 128;
  1120.     Renew(loop_stack, loop_max, struct loop);
  1121.     }
  1122.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1123.     loop_stack[loop_ptr].loop_sp = sp;
  1124. #ifdef DEBUGGING
  1125.     if (debug & 4) {
  1126.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1127.     }
  1128. #endif
  1129.     eval_root = Nullcmd;
  1130.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1131.     retval = 1;
  1132.     }
  1133.     else {
  1134.     error_count = 0;
  1135.     if (rsfp) {
  1136.         retval = yyparse();
  1137.         retval |= error_count;
  1138.     }
  1139.     else if (last_root && last_elen == bufend - bufptr
  1140.       && *bufptr == *last_eval && !bcmp(bufptr,last_eval,last_elen)){
  1141.         retval = 0;
  1142.         eval_root = last_root;    /* no point in reparsing */
  1143.     }
  1144.     else if (in_eval == 1 && !savecmd) {
  1145.         if (last_root) {
  1146.         Safefree(last_eval);
  1147.         last_eval = Nullch;
  1148.         cmd_free(last_root);
  1149.         }
  1150.         last_root = Nullcmd;
  1151.         last_elen = bufend - bufptr;
  1152.         last_eval = nsavestr(bufptr, last_elen);
  1153.         retval = yyparse();
  1154.         retval |= error_count;
  1155.         if (!retval)
  1156.         last_root = eval_root;
  1157.         if (!last_root) {
  1158.         Safefree(last_eval);
  1159.         last_eval = Nullch;
  1160.         }
  1161.     }
  1162.     else
  1163.         retval = yyparse();
  1164.     }
  1165.     myroot = eval_root;        /* in case cmd_exec does another eval! */
  1166.  
  1167.     if (retval || error_count) {
  1168.     st = stack->ary_array;
  1169.     sp = arglast[0];
  1170.     if (gimme != G_ARRAY)
  1171.         st[++sp] = &str_undef;
  1172.     if (parsing) {
  1173. #ifndef MANGLEDPARSE
  1174. #ifdef DEBUGGING
  1175.         if (debug & 128)
  1176.         fprintf(stderr,"Freeing eval_root %lx\n",(long)eval_root);
  1177. #endif
  1178.         cmd_free(eval_root);
  1179. #endif
  1180.         /*SUPPRESS 29*/ /*SUPPRESS 30*/
  1181.         if ((CMD*)eval_root == last_root)
  1182.         last_root = Nullcmd;
  1183.         eval_root = myroot = Nullcmd;
  1184.     }
  1185.     if (rsfp) {
  1186.         fclose(rsfp);
  1187.         rsfp = 0;
  1188.     }
  1189.     }
  1190.     else {
  1191.     parsing = 0;
  1192.     sp = cmd_exec(eval_root,gimme,sp);
  1193.     st = stack->ary_array;
  1194.     for (i = arglast[0] + 1; i <= sp; i++)
  1195.         st[i] = str_mortal(st[i]);
  1196.                 /* if we don't save result, free zaps it */
  1197.     if (savecmd)
  1198.         eval_root = myroot;
  1199.     else if (in_eval != 1 && myroot != last_root)
  1200.         cmd_free(myroot);
  1201.     }
  1202.  
  1203.     perldb = oldperldb;
  1204.     in_eval--;
  1205. #ifdef DEBUGGING
  1206.     if (debug & 4) {
  1207.     char *tmps = loop_stack[loop_ptr].loop_label;
  1208.     deb("(Popping label #%d %s)\n",loop_ptr,
  1209.         tmps ? tmps : "" );
  1210.     }
  1211. #endif
  1212.     loop_ptr--;
  1213.     tmps_base = oldtmps_base;
  1214.     curspat = oldspat;
  1215.     lastspat = oldlspat;
  1216.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1217.     restorelist(oldsave);
  1218.  
  1219.     if (optype != O_EVAL) {
  1220.     if (retval) {
  1221.         if (optype == O_REQUIRE)
  1222.         fatal("%s", str_get(stab_val(stabent("@",TRUE))));
  1223.     }
  1224.     else {
  1225.         curcmd = oldcurcmd;
  1226.         if (gimme == G_SCALAR ? str_true(st[sp]) : sp > arglast[0]) {
  1227.         (void)hstore(stab_hash(incstab), specfilename,
  1228.           strlen(specfilename), str_smake(stab_val(curcmd->c_filestab)),
  1229.               0 );
  1230.         }
  1231.         else if (optype == O_REQUIRE)
  1232.         fatal("%s did not return a true value", specfilename);
  1233.     }
  1234.     }
  1235.     curcmd = oldcurcmd;
  1236.     return sp;
  1237. }
  1238.  
  1239. int
  1240. do_try(cmd,gimme,arglast)
  1241. CMD *cmd;
  1242. int gimme;
  1243. int *arglast;
  1244. {
  1245.     STR **st = stack->ary_array;
  1246.  
  1247.     CMD * VOLATILE oldcurcmd = curcmd;
  1248.     VOLATILE int oldtmps_base = tmps_base;
  1249.     VOLATILE int oldsave = savestack->ary_fill;
  1250.     SPAT * VOLATILE oldspat = curspat;
  1251.     SPAT * VOLATILE oldlspat = lastspat;
  1252.     VOLATILE int sp = arglast[0];
  1253.  
  1254.     tmps_base = tmps_max;
  1255.     str_set(stab_val(stabent("@",TRUE)),"");
  1256.     in_eval++;
  1257.     if (++loop_ptr >= loop_max) {
  1258.     loop_max += 128;
  1259.     Renew(loop_stack, loop_max, struct loop);
  1260.     }
  1261.     loop_stack[loop_ptr].loop_label = "_EVAL_";
  1262.     loop_stack[loop_ptr].loop_sp = sp;
  1263. #ifdef DEBUGGING
  1264.     if (debug & 4) {
  1265.     deb("(Pushing label #%d _EVAL_)\n", loop_ptr);
  1266.     }
  1267. #endif
  1268.     if (setjmp(loop_stack[loop_ptr].loop_env)) {
  1269.     st = stack->ary_array;
  1270.     sp = arglast[0];
  1271.     if (gimme != G_ARRAY)
  1272.         st[++sp] = &str_undef;
  1273.     }
  1274.     else {
  1275.     sp = cmd_exec(cmd,gimme,sp);
  1276.     st = stack->ary_array;
  1277. /*    for (i = arglast[0] + 1; i <= sp; i++)
  1278.         st[i] = str_mortal(st[i]);  not needed, I think */
  1279.                 /* if we don't save result, free zaps it */
  1280.     }
  1281.  
  1282.     in_eval--;
  1283. #ifdef DEBUGGING
  1284.     if (debug & 4) {
  1285.     char *tmps = loop_stack[loop_ptr].loop_label;
  1286.     deb("(Popping label #%d %s)\n",loop_ptr,
  1287.         tmps ? tmps : "" );
  1288.     }
  1289. #endif
  1290.     loop_ptr--;
  1291.     tmps_base = oldtmps_base;
  1292.     curspat = oldspat;
  1293.     lastspat = oldlspat;
  1294.     curcmd = oldcurcmd;
  1295.     if (savestack->ary_fill > oldsave)    /* let them use local() */
  1296.     restorelist(oldsave);
  1297.  
  1298.     return sp;
  1299. }
  1300.  
  1301. /* This routine handles any switches that can be given during run */
  1302.  
  1303. static char *
  1304. moreswitches(s)
  1305. char *s;
  1306. {
  1307.     int numlen;
  1308.  
  1309.     switch (*s) {
  1310.     case '0':
  1311.     nrschar = scanoct(s, 4, &numlen);
  1312.     nrs = nsavestr("\n",1);
  1313.     *nrs = nrschar;
  1314.     if (nrschar > 0377) {
  1315.         nrslen = 0;
  1316.         nrs = "";
  1317.     }
  1318.     else if (!nrschar && numlen >= 2) {
  1319.         nrslen = 2;
  1320.         nrs = "\n\n";
  1321.         nrschar = '\n';
  1322.     }
  1323.     return s + numlen;
  1324.     case 'a':
  1325.     minus_a = TRUE;
  1326.     s++;
  1327.     return s;
  1328.     case 'c':
  1329.     minus_c = TRUE;
  1330.     s++;
  1331.     return s;
  1332.     case 'd':
  1333. #ifdef TAINT
  1334.     if (euid != uid || egid != gid)
  1335.         fatal("No -d allowed in setuid scripts");
  1336. #endif
  1337.     perldb = TRUE;
  1338.     s++;
  1339.     return s;
  1340.     case 'D':
  1341. #ifdef DEBUGGING
  1342. #ifdef TAINT
  1343.     if (euid != uid || egid != gid)
  1344.         fatal("No -D allowed in setuid scripts");
  1345. #endif
  1346.     debug = atoi(s+1) | 32768;
  1347. #else
  1348.     warn("Recompile perl with -DDEBUGGING to use -D switch\n");
  1349. #endif
  1350.     /*SUPPRESS 530*/
  1351.     for (s++; isDIGIT(*s); s++) ;
  1352.     return s;
  1353.     case 'i':
  1354.     inplace = savestr(s+1);
  1355.     /*SUPPRESS 530*/
  1356.     for (s = inplace; *s && !isSPACE(*s); s++) ;
  1357.     *s = '\0';
  1358.     break;
  1359.     case 'I':
  1360. #ifdef TAINT
  1361.     if (euid != uid || egid != gid)
  1362.         fatal("No -I allowed in setuid scripts");
  1363. #endif
  1364.     if (*++s) {
  1365.         (void)apush(stab_array(incstab),str_make(s,0));
  1366.     }
  1367.     else
  1368.         fatal("No space allowed after -I");
  1369.     break;
  1370.     case 'l':
  1371.     minus_l = TRUE;
  1372.     s++;
  1373.     if (isDIGIT(*s)) {
  1374.         ors = savestr("\n");
  1375.         orslen = 1;
  1376.         *ors = scanoct(s, 3 + (*s == '0'), &numlen);
  1377.         s += numlen;
  1378.     }
  1379.     else {
  1380.         ors = nsavestr(nrs,nrslen);
  1381.         orslen = nrslen;
  1382.     }
  1383.     return s;
  1384.     case 'n':
  1385.     minus_n = TRUE;
  1386.     s++;
  1387.     return s;
  1388.     case 'p':
  1389.     minus_p = TRUE;
  1390.     s++;
  1391.     return s;
  1392.     case 'u':
  1393.     do_undump = TRUE;
  1394.     s++;
  1395.     return s;
  1396.     case 'U':
  1397.     unsafe = TRUE;
  1398.     s++;
  1399.     return s;
  1400.     case 'v':
  1401.     fputs("\nThis is perl, version 4.0\n\n",stdout);
  1402.     fputs(rcsid,stdout);
  1403.     fputs("\nCopyright (c) 1989, 1990, 1991, Larry Wall\n",stdout);
  1404. #ifdef MSDOS
  1405.     fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
  1406.     stdout);
  1407. #ifdef DJGPP
  1408.     fputs("MS-DOS hack (using DJGPP) Copyright (c) 1992, Hitoshi Doi\n",
  1409.     stdout);
  1410. #endif /* DJGPP */
  1411. #ifdef OS2
  1412.         fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n",
  1413.         stdout);
  1414. #endif
  1415. #endif
  1416. #ifdef atarist
  1417.         fputs("atariST series port, ++jrb  bammi@cadence.com\n", stdout);
  1418. #endif
  1419.     fputs("\n\
  1420. Perl may be copied only under the terms of either the Artistic License or the\n\
  1421. GNU General Public License, which may be found in the Perl 4.0 source kit.\n",stdout);
  1422. #ifdef MSDOS
  1423. #ifndef DJGPP
  1424.         usage(origargv[0]);
  1425. #endif /* !DJGPP */
  1426. #endif
  1427.     exit(0);
  1428.     case 'w':
  1429.     dowarn = TRUE;
  1430.     s++;
  1431.     return s;
  1432.     case ' ':
  1433.     case '\n':
  1434.     case '\t':
  1435.     break;
  1436.     default:
  1437.     fatal("Switch meaningless after -x: -%s",s);
  1438.     }
  1439.     return Nullch;
  1440. }
  1441.  
  1442. /* compliments of Tom Christiansen */
  1443.  
  1444. /* unexec() can be found in the Gnu emacs distribution */
  1445.  
  1446. void
  1447. my_unexec()
  1448. {
  1449. #ifdef UNEXEC
  1450.     int    status;
  1451.     extern int etext;
  1452.     static char dumpname[BUFSIZ];
  1453.     static char perlpath[256];
  1454.  
  1455.     sprintf (dumpname, "%s.perldump", origfilename);
  1456.     sprintf (perlpath, "%s/perl", BIN);
  1457.  
  1458.     status = unexec(dumpname, perlpath, &etext, sbrk(0), 0);
  1459.     if (status)
  1460.     fprintf(stderr, "unexec of %s into %s failed!\n", perlpath, dumpname);
  1461.     exit(status);
  1462. #else
  1463. #ifdef DOSISH
  1464.     abort();    /* nothing else to do */
  1465. #else /* ! MSDOS */
  1466. #   ifndef SIGABRT
  1467. #    define SIGABRT SIGILL
  1468. #   endif
  1469. #   ifndef SIGILL
  1470. #    define SIGILL 6        /* blech */
  1471. #   endif
  1472.     kill(getpid(),SIGABRT);    /* for use with undump */
  1473. #endif /* ! MSDOS */
  1474. #endif
  1475. }
  1476.  
  1477.